home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / OTHER_LA / QUINTA / SYMBOLIC.Q < prev    next >
Text File  |  1990-04-28  |  6KB  |  251 lines
  1. ; ----------------------------------------------------------------
  2. ; Symbolic Algebra in Quinta
  3. ; Eric W. Sink
  4.  
  5. ticks
  6. "Defining classes" print cr flush
  7.  
  8. {} "func" "args" 2 >list "symbolic" generic subclass
  9. [ 'args' sto 'func' sto ] symbolic setbld
  10.  
  11. {} {} "symbsum" symbolic subclass
  12. [ _+_ swap rot swap symbolic bld ] symbsum setbld
  13.  
  14. {} {} "symbprod" symbolic subclass
  15. [ _*_ swap rot swap symbolic bld ] symbprod setbld
  16.  
  17. {} {} "symbdiff" symbolic subclass
  18. [ _-_ swap rot swap symbolic bld ] symbdiff setbld
  19.  
  20. {} {} "symbquot" symbolic subclass
  21. [ _/_ swap rot swap symbolic bld ] symbquot setbld
  22.  
  23. {} {} "symbpow" symbolic subclass
  24. [ _^_ swap rot swap symbolic bld ] symbpow setbld
  25.  
  26. {} {} "symbconst" symbolic subclass
  27. [ symbolic bld ] symbconst setbld
  28.  
  29. {} {} "symbvar" symbolic subclass
  30. [ symbolic bld ] symbvar setbld
  31.  
  32. {} {} "symbsin" symbolic subclass
  33. [ _sin_ swap rot swap  symbolic bld ] symbsin setbld
  34.  
  35. {} {} "symbcos" symbolic subclass
  36. [ _cos_ swap rot swap  symbolic bld ] symbcos setbld
  37.  
  38. {} {} "symbtan" symbolic subclass
  39. [ _tan_ swap rot swap  symbolic bld ] symbtan setbld
  40.  
  41. {} {} "symbsqrt" symbolic subclass
  42. [ _sqrt_ swap rot swap  symbolic bld ] symbsqrt setbld
  43.  
  44. {} {} "symbexp" symbolic subclass
  45. [ _exp_ swap rot swap  symbolic bld ] symbexp setbld
  46.  
  47. {} {} "symblog" symbolic subclass
  48. [ _log_ swap rot swap  symbolic bld ] symblog setbld
  49.  
  50. {} {} "symblog10" symbolic subclass
  51. [ _log10_ swap rot swap  symbolic bld ] symblog10 setbld
  52.  
  53. {} {} "symbalog" symbolic subclass
  54. [ _alog_ swap rot swap  symbolic bld ] symbalog setbld
  55.  
  56. {} {} "symbinv" symbolic subclass
  57. [ _inv_ swap rot swap  symbolic bld ] symbinv setbld
  58.  
  59. {} {} "symbneg" symbolic subclass
  60. [ _neg_ swap rot swap  symbolic bld ] symbneg setbld
  61.  
  62. "Done Defining classes" print cr flush
  63. ; ----------------------------------------------------------------
  64. ; Conversions to symbolics
  65.  
  66. [ {} symbconst new ] ">symbolic" pub quantity respond
  67.  
  68. [ {} symbvar new ] ">symbolic" pub variable respond
  69.  
  70. ; ----------------------------------------------------------------
  71. ; Predicates for symbolic classes
  72. ; This set of functions could be replaced by classof checks
  73.  
  74. [ classof message same ] "message?" pub generic respond
  75.  
  76. [ func dup message? not swap classof variable same not and ]
  77. "constant?" pub symbolic respond
  78.  
  79. [ func _+_ same ] "sum?" pub symbolic respond
  80.  
  81. [ func _*_ same ] "product?" pub symbolic respond
  82.  
  83. [ func _-_ same ] "difference?" pub symbolic respond
  84.  
  85. [ func _/_ same ] "quotient?" pub symbolic respond
  86.  
  87. ; ----------------------------------------------------------------
  88. ; Definitions of eval
  89.  
  90. [ ] "eval" pub generic respond
  91.  
  92. [ rcl ] "eval" pub variable respond
  93.  
  94. [ "s" local [ s func ] [ s args _eval_ apply s func sendthru ]
  95. s func message? cond ] "eval" pub symbolic respond
  96.  
  97. ; ----------------------------------------------------------------
  98. ; Textual representation of symbolics
  99.  
  100. [ "s" local [ s func >str ] [ s func >str s args >str + ]
  101. s constant? not cond ] ">str"
  102. pub symbolic respond
  103.  
  104. ; ----------------------------------------------------------------
  105. ; Arithmetic operations on symbolics
  106.  
  107. ; Addition
  108.  
  109. [ "a" local "s" local 
  110. s func a s args cons symbsum new  ]
  111. "+" pub generic symbsum 2 >list respond
  112.  
  113. [ 2 >list symbsum new ] 
  114. "+" pub generic symbolic 2 >list respond
  115.  
  116. [ "s" local "a" local 
  117. s func a s args cons symbsum new  ]
  118. "+" pub symbsum generic 2 >list respond
  119.  
  120. [ 2 >list symbsum new ] 
  121. "+" pub symbolic generic 2 >list respond
  122.  
  123. ; Multiplication
  124.  
  125. [ "a" local "s" local 
  126. s func a s args cons symbprod new  ]
  127. "*" pub generic symbprod 2 >list respond
  128.  
  129. [ 2 >list symbprod new ] 
  130. "*" pub generic symbolic 2 >list respond
  131.  
  132. [ "s" local "a" local 
  133. s func a s args cons symbprod new  ]
  134. "*" pub symbprod generic 2 >list respond
  135.  
  136. [ 2 >list symbprod new ] 
  137. "*" pub symbolic generic 2 >list respond
  138.  
  139. ; Subtraction
  140.  
  141. [ "a" local "s" local 
  142. s func a s args cons symbdiff new  ]
  143. "-" pub generic symbdiff 2 >list respond
  144.  
  145. [ 2 >list symbdiff new ] 
  146. "-" pub generic symbolic 2 >list respond
  147.  
  148. [ "s" local "a" local 
  149. s func a s args cons symbdiff new  ]
  150. "-" pub symbdiff generic 2 >list respond
  151.  
  152. [ 2 >list symbdiff new ] 
  153. "-" pub symbolic generic 2 >list respond
  154.  
  155. ; Division
  156.  
  157. [ "a" local "s" local 
  158. s func a s args cons symbquot new  ]
  159. "/" pub generic symbquot 2 >list respond
  160.  
  161. [ 2 >list symbquot new ] 
  162. "/" pub generic symbolic 2 >list respond
  163.  
  164. [ "s" local "a" local 
  165. s func a s args cons symbquot new  ]
  166. "/" pub symbquot generic 2 >list respond
  167.  
  168. [ 2 >list symbquot new ] 
  169. "/" pub symbolic generic 2 >list respond
  170.  
  171. ; Exponentiation
  172.  
  173. [ "a" local "s" local 
  174. s func a s args cons symbpow new  ]
  175. "^" pub generic symbquot 2 >list respond
  176.  
  177. [ 2 >list symbpow new ] 
  178. "^" pub generic symbolic 2 >list respond
  179.  
  180. [ "s" local "a" local 
  181. s func a s args cons symbpow new  ]
  182. "^" pub symbpow generic 2 >list respond
  183.  
  184. [ 2 >list symbpow new ] 
  185. "^" pub symbolic generic 2 >list respond
  186.  
  187. ; Misc functions
  188.  
  189. [ 1 >list symbexp new ]
  190. "exp" pub symbolic respond
  191.  
  192. [ 1 >list symbsin new ]
  193. "sin" pub symbolic respond
  194.  
  195. [ 1 >list symbcos new ]
  196. "cos" pub symbolic respond
  197.  
  198. [ 1 >list symbtan new ]
  199. "tan" pub symbolic respond
  200.  
  201. [ 1 >list symblog new ]
  202. "log" pub symbolic respond
  203.  
  204. [ 1 >list symblog10 new ]
  205. "log10" pub symbolic respond
  206.  
  207. [ 1 >list symbalog new ]
  208. "alog" pub symbolic respond
  209.  
  210. [ 1 >list symbsqrt new ]
  211. "sqrt" pub symbolic respond
  212.  
  213. [ 1 >list symbneg new ]
  214. "neg" pub symbolic respond
  215.  
  216. [ 1 >list symbinv new ]
  217. "inv" pub symbolic respond
  218.  
  219. ; -----------------------------------------------------------------
  220. ; Derivation
  221.  
  222. [ "m" local "a" local "L" local L size "cnt" local
  223.     [ L car L cdr 'L' sto a m send ]
  224.     [ L isempty not ]
  225.     whiledo
  226.     cnt >list ]
  227. "applyarg" pub message respond
  228.  
  229. [ drop2 0 ] "der" pub variable quantity 2 >list respond
  230.  
  231. [ "dv" local "e" local
  232.   [ 0 ]
  233.   [ 1 ]
  234.   dv e same cond ] "der" pub variable variable 2 >list respond
  235.  
  236. [ "dv" local "e" local e args dv _der_ applyarg sum]
  237. "der" pub variable symbsum 2 >list respond
  238.  
  239. ; This routine was written by Jurjen N.E. Bos (jurjen@cwi.nl)
  240. ; for the HP-28 calculator.  Very little conversion was necessary
  241. ; for Quinta to handle it nicely.  Also, I modified his code
  242. ; to always operate at the highest precision possible for SANE.
  243.  
  244. [ 15.0 neg alog 2 / "p" local "x" local 1 "a" local 0 "b" local
  245. x [ inv dup ip abs a * b + a 'b' sto 'a' sto fp ] 
  246. [ x a * 0.5 + floor x a * - abs p a * >= ]
  247. whiledo
  248. drop x a * 0.5 + floor a >symbolic / ] "frac" pub float respond
  249.  
  250. ticks swap - 60 / >str " seconds to LOAD" + print cr
  251.